home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
kcl
/
kcl.lha
/
cmpnew
/
cmpcall.lsp
< prev
next >
Wrap
Lisp/Scheme
|
1987-06-03
|
11KB
|
269 lines
;;; CMPCALL Function call.
;;;
;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984. All rights reserved.
;; Copying of this file is authorized to users who have executed the true and
;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
(in-package 'compiler)
(si:putprop 'funcall 'c2funcall 'c2)
(si:putprop 'call-lambda 'c2call-lambda 'c2)
(si:putprop 'call-global 'c2call-global 'c2)
(defun c1funob (fun &aux fd)
;;; NARGS is the number of arguments. If the number is unknown, (e.g.
;;; in case of APPLY), then NARGS should be NIL.
(or
(and
(consp fun)
(or (and (eq (car fun) 'quote)
(not (endp (cdr fun)))
(endp (cddr fun))
(or (and (consp (cadr fun))
(not (endp (cdadr fun)))
(eq (caadr fun) 'lambda)
(let ((*vars* nil) (*funs* nil) (*blocks* nil)
(*tags* nil))
(let ((lambda-expr (c1lambda-expr (cdadr fun))))
(list 'call-lambda (cadr lambda-expr)
lambda-expr))))
(and (symbolp (cadr fun))
(or (and (setq fd (c1local-fun (cadr fun)))
(eq (car fd) 'call-local)
fd)
(list 'call-global
(make-info
:sp-change
(null (get (cadr fun) 'no-sp-change)))
(cadr fun)))
)))
(and (eq (car fun) 'function)
(not (endp (cdr fun)))
(endp (cddr fun))
(or (and (consp (cadr fun))
(eq (caadr fun) 'lambda)
(not (endp (cdadr fun)))
(let ((lambda-expr (c1lambda-expr (cdadr fun))))
(list 'call-lambda (cadr lambda-expr) lambda-expr))
)
(and (symbolp (cadr fun))
(or (and (setq fd (c1local-fun (cadr fun)))
(eq (car fd) 'call-local)
fd)
(list 'call-global
(make-info
:sp-change
(null (get (cadr fun) 'no-sp-change)))
(cadr fun)))
)))))
(let ((x (c1expr fun)) (info (make-info :sp-change t)))
(add-info info (cadr x))
(list 'ordinary info x))
))
(defun c2funcall (funob args &optional (loc nil))
;;; Usually, ARGS holds a list of forms, which are arguments to the
;;; function. If, however, the arguments are already pushed on the stack,
;;; ARGS should be set to the symbol ARGS-PUSHED.
(case (car funob)
(call-global (c2call-global (caddr funob) args loc t))
(call-local (c2call-local (cddr funob) args))
(call-lambda (c2call-lambda (caddr funob) args))
(ordinary ;;; An ordinary expression. In this case, if
;;; arguments are already pushed on the stack, then
;;; LOC cannot be NIL. Callers of C2FUNCALL must be
;;; responsible for maintaining this condition.
(let ((*vs* *vs*) (form (caddr funob)))
(declare (object form))
(unless loc
(unless (listp args) (baboon))
(cond ((eq (car form) 'LOCATION) (setq loc (caddr form)))
((and (eq (car form) 'VAR)
(not (args-info-changed-vars (caaddr form) args)))
(setq loc (cons 'VAR (caddr form))))
(t
(setq loc (list 'vs (vs-push)))
(let ((*value-to-go* loc)) (c2expr* (caddr funob))))))
(push-args args)
(if *compiler-push-events*
(wt-nl "super_funcall(" loc ");")
(wt-nl "super_funcall_no_event(" loc ");"))
(unwind-exit 'fun-val)))
(otherwise (baboon))
))
(defun c2call-lambda (lambda-expr args &aux (lambda-list (caddr lambda-expr)))
(declare (object lambda-list))
(cond ((or (cadr lambda-list) ;;; Has optional?
(caddr lambda-list) ;;; Has rest?
(cadddr lambda-list) ;;; Has key?
(not (listp args)) ;;; Args already pushed?
)
(when (listp args) ;;; Args already pushed?
(let ((*vs* *vs*) (base *vs*))
(push-args-lispcall args)
(when (need-to-set-vs-pointers lambda-list)
(wt-nl "vs_top=(vs_base=base+" base ")+" (- *vs* base) ";")
(base-used)
)))
(c2lambda-expr lambda-list (caddr (cddr lambda-expr)))
)
(t (c2let (car lambda-list) args (caddr (cddr lambda-expr)))))
)
(defun c2call-global (fname args loc return-type &aux fd (*vs* *vs*))
(if (inline-possible fname)
(cond
;;; Tail-recursive case.
((and (listp args)
*do-tail-recursion*
*tail-recursion-info*
(eq (car *tail-recursion-info*) fname)
(member *exit*
'(RETURN RETURN-FIXNUM RETURN-CHARACTER RETURN-SHORT-FLOAT
RETURN-LONG-FLOAT RETURN-OBJECT))
(tail-recursion-possible)
(= (length args) (length (cdr *tail-recursion-info*))))
(let* ((*value-to-go* 'trash)
(*exit* (next-label))
(*unwind-exit* (cons *exit* *unwind-exit*)))
(c2psetq (mapcar #'(lambda (v) (list v nil))
(cdr *tail-recursion-info*))
args)
(wt-label *exit*))
(unwind-no-exit 'tail-recursion-mark)
(wt-nl "goto TTL;")
(cmpnote "Tail-recursive call of ~s was replaced by iteration." fname))
;;; Open-codable function call.
((and (listp args)
(null loc)
(setq fd (get-inline-info fname args return-type)))
(let ((*inline-blocks* 0))
(unwind-exit (get-inline-loc fd args))
(close-inline-blocks)))
;;; Call to a function whose C language function name is known.
((setq fd (or (get fname 'Lfun) (get fname 'Ufun)))
(push-args args)
(wt-nl fd "();")
(unwind-exit 'fun-val)
)
;;; Call to a function defined in the same file.
((setq fd (assoc fname *global-funs*))
(push-args args)
(wt-nl "L" (cdr fd) "();")
(unwind-exit 'fun-val)
)
;;; Otherwise.
(t (c2call-unknown-global fname args loc t)))
(c2call-unknown-global fname args loc nil))
)
(si:putprop 'simple-call 'wt-simple-call 'wt-loc)
(defun wt-simple-call (cfun base n &optional (vv-index nil))
(wt "simple_" cfun "(")
(when vv-index (wt "VV[" vv-index "],"))
(wt "base+" base "," n ")")
(base-used))
;;; Functions that use SAVE-FUNOB should reset *vs*.
(defun save-funob (funob)
(case (car funob)
((call-lambda call-quote-lambda call-local))
(call-global
(unless (and (inline-possible (caddr funob))
(or (get (caddr funob) 'Lfun)
(get (caddr funob) 'Ufun)
(assoc (caddr funob) *global-funs*)))
(let ((temp (list 'vs (vs-push))))
(if *safe-compile*
(wt-nl
temp
"=symbol_function(VV[" (add-symbol (caddr funob)) "]);")
(wt-nl temp
"=VV[" (add-symbol (caddr funob)) "]->s.s_gfdef;"))
temp)))
(ordinary (let* ((temp (list 'vs (vs-push)))
(*value-to-go* temp))
(c2expr* (caddr funob))
temp))
(otherwise (baboon))
))
(defun push-args (args)
(cond ((null args) (wt-nl "vs_base=vs_top;"))
((consp args)
(let ((*vs* *vs*) (base *vs*))
(dolist** (arg args)
(let ((*value-to-go* (list 'vs (vs-push))))
(c2expr* arg)))
(wt-nl "vs_top=(vs_base=base+" base ")+" (- *vs* base) ";")
(base-used)))))
(defun push-args-lispcall (args)
(dolist** (arg args)
(let ((*value-to-go* (list 'vs (vs-push))))
(c2expr* arg))))
(defun c2call-unknown-global (fname args loc inline-p)
(cond (*compiler-push-events*
;;; Want to set up the return catcher.
(unless loc
(setq loc (list 'vs (vs-push)))
(wt-nl loc "=symbol_function(VV[" (add-symbol fname) "]);"))
(push-args args)
(wt-nl "funcall_with_catcher(VV[" (add-symbol fname) "]," loc ");")
(unwind-exit 'fun-val))
(loc
;;; The function was already pushed.
(push-args args)
(if inline-p
(if *safe-compile*
(wt-nl "funcall_no_event(" loc ");")
(wt-nl "CMPfuncall(" loc ");"))
(wt-nl "funcall(" loc ");"))
(unwind-exit 'fun-val))
((args-cause-side-effect args)
;;; Evaluation of the arguments may cause side-effect.
;;; Arguments are not yet pushed.
(let ((base *vs*))
(setq loc (list 'vs (vs-push)))
(if *safe-compile*
(wt-nl loc "=symbol_function(VV[" (add-symbol fname) "]);")
(wt-nl loc "=(VV[" (add-symbol fname) "]->s.s_gfdef);"))
(push-args-lispcall args)
(cond ((or (eq *value-to-go* 'return)
(eq *value-to-go* 'top))
(wt-nl "lispcall")
(when inline-p (wt "_no_event"))
(wt "(base+" base "," (length args) ");")
(base-used)
(unwind-exit 'fun-val))
(t (unwind-exit
(list 'SIMPLE-CALL
(if inline-p "lispcall_no_event" "lispcall")
base (length args))))))
)
(t
;;; Evaluation of the arguments causes no side-effect.
;;; Arguments are not yet pushed.
(let ((base *vs*))
(push-args-lispcall args)
(cond ((or (eq *value-to-go* 'return)
(eq *value-to-go* 'top))
(wt-nl "symlispcall")
(when inline-p (wt "_no_event"))
(wt "(VV[" (add-symbol fname) "],base+" base ","
(length args) ");")
(base-used)
(unwind-exit 'fun-val))
(t (unwind-exit
(list 'SIMPLE-CALL
(if inline-p "symlispcall_no_event" "symlispcall")
base (length args) (add-symbol fname))))))
)))